home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / aboutw / about.bas next >
Encoding:
BASIC Source File  |  1994-10-09  |  6.4 KB  |  243 lines
  1. Option Explicit
  2.  
  3.     Type RECT
  4.     Left As Integer
  5.     Top As Integer
  6.     Right As Integer
  7.     Bottom As Integer
  8.     End Type
  9.  
  10.     Global Const GWW_HINSTANCE = (-6)
  11.     
  12.     
  13.     Declare Function GetFreeSpace& Lib "Kernel" (ByVal wFlags%)
  14.     Declare Function GetFreeSystemResources% Lib "User" (ByVal fuSysResource%)
  15.     Declare Function GetWinFlags& Lib "Kernel" ()
  16.     Declare Function GetVersion& Lib "Kernel" ()
  17.     Declare Function GetModuleHandle% Lib "Kernel" (ByVal lpModuleName$)
  18.     Declare Function LoadString% Lib "User" (ByVal hInstance%, ByVal wID%, ByVal lpBuffer$, ByVal nBufferMax%)
  19.     Declare Function SelectObject% Lib "GDI" (ByVal hDC%, ByVal hObject%)
  20.     Declare Function CreateSolidBrush% Lib "GDI" (ByVal crColor&)
  21.     Declare Function DeleteObject% Lib "GDI" (ByVal hObject%)
  22.     Declare Function GetDC% Lib "User" (ByVal hWnd%)
  23.     Declare Sub GetWindowRect Lib "User" (ByVal hWnd%, lpRect As RECT)
  24.     Declare Function Rectangle% Lib "GDI" (ByVal hDC%, ByVal X1%, ByVal Y1%, ByVal X2%, ByVal Y2%)
  25.     Declare Function ReleaseDC% Lib "User" (ByVal hWnd%, ByVal hDC%)
  26.     Declare Function GetWindowsDirectory% Lib "Kernel" (ByVal lpBuffer$, ByVal nSize%)
  27.     Declare Function GetSystemDirectory% Lib "Kernel" (ByVal lpBuffer$, ByVal nSize%)
  28.     Declare Function GetCurrentTask% Lib "Kernel" ()
  29.     Declare Function GetModuleFileName% Lib "Kernel" (ByVal hModule%, ByVal lpFilename$, ByVal nSize%)
  30.     Declare Function GetWindowWord% Lib "User" (ByVal hWnd%, ByVal nIndex%)
  31.     Declare Function ExtractIcon% Lib "Shell" (ByVal hInst%, ByVal FileName$, ByVal iIcon%)
  32.     Declare Function DestroyIcon% Lib "user" (ByVal hIcon%)
  33.     Declare Function GlobalSize& Lib "kernel" (ByVal hGlobal%)
  34.     Declare Function GlobalLock& Lib "kernel" (ByVal hGlobal%)
  35.     Declare Function GlobalUnlock% Lib "kernel" (ByVal hGlobal%)
  36.     Declare Sub hmemcpy Lib "kernel" (ByVal hpDest&, ByVal hpSource&, ByVal cbCopy&)
  37.  
  38. Function AppIcon2Pic% (Pic As PictureBox)
  39.  
  40.     Dim hIcon%
  41.     Dim Rc%
  42.     Dim hInst%
  43.  
  44.     hInst% = GetWindowWord%(Pic.hWnd, GWW_HINSTANCE)
  45.     
  46.     hIcon% = ExtractIcon%(hInst%, ExeName$(hInst%), 0)
  47.     If hIcon% Then
  48.     AppIcon2Pic% = CopyIcon%(hIcon%, (Pic.Picture))
  49.     Rc% = DestroyIcon%(hIcon%)
  50.     End If
  51.  
  52. End Function
  53.  
  54. Function CopyIcon% (hSource%, hDest%)
  55.     
  56. '~~~~~ Copies the icon from *hSource to *hDest, provided the
  57. '~~~~~ memory blocks at *hSource and *hDest are the same size.
  58. '~~~~~ hSource and hDest are Handles to Icons
  59.     
  60.     Dim sizeSource&, sizeDest&
  61.     Dim fpSource&, fpDest&
  62.     Dim Rc%
  63.     
  64.     CopyIcon% = False
  65.     
  66.     ' get size of memory blocks
  67.     sizeSource& = GlobalSize&(hSource%)
  68.     sizeDest& = GlobalSize&(hDest%)
  69.     
  70.     If sizeDest& <> sizeSource& Then
  71.     If sizeSource& <> 288 Then  ' not a monochrome icon
  72.         Exit Function
  73.     End If
  74.     End If
  75.     
  76.     ' lock memory and get far pointers to Source & Destination
  77.     fpSource& = GlobalLock&(hSource%)
  78.     fpDest& = GlobalLock&(hDest%)
  79.     
  80.     ' copy Source to Destination
  81.     hmemcpy fpDest&, fpSource&, sizeSource&
  82.     
  83.     ' unlock memory
  84.     Rc% = GlobalUnlock%(hDest)
  85.     Rc% = GlobalUnlock%(hSource)
  86.  
  87.     CopyIcon% = True
  88.  
  89. End Function
  90.  
  91. Function ExeName$ (hInst%)
  92.     
  93.     Dim Temp$
  94.     Dim NameLen%
  95.     
  96.     Temp$ = String(255, Chr$(0))
  97.     NameLen% = GetModuleFileName%(hInst%, Temp$, Len(Temp$))
  98.     If NameLen% Then
  99.     ExeName$ = Left$(Temp$, NameLen%)
  100.     Else
  101.     ExeName$ = "<Unknown>"
  102.     End If
  103.  
  104. End Function
  105.  
  106. Function FormatLong$ (TheNum&)
  107.     
  108.     Dim TheStr$
  109.  
  110.     TheStr$ = Space$(11)
  111.  
  112.     RSet TheStr$ = Format$(TheNum&, "###,###,##0")
  113.  
  114.     FormatLong$ = TheStr$
  115.  
  116. End Function
  117.  
  118. Sub FormCenter (Frm As Form)
  119.     
  120.     Dim TheTop%, TheLeft%
  121.  
  122.     TheTop% = (Screen.Height - Frm.Height) / 2
  123.     TheLeft% = (Screen.Width - Frm.Width) / 2
  124.  
  125.     Frm.Move TheLeft%, TheTop%
  126.  
  127. End Sub
  128.  
  129. Sub FormExplode (Frm As Form)
  130.  
  131. ' "explodes" a form by drawing successively larger rectangles,
  132. ' using the form's background color, to fill the form area.
  133. ' Should be called from the Form_Load event procedure.
  134.  
  135. ' Number of steps to use in expanding the rectangle. More steps
  136. ' result in a slower but smoother "explosion."
  137.  
  138.     Const STEPS = 60
  139.  
  140.     Dim FormWidth%
  141.     Dim FormHeight%
  142.     Dim Count%
  143.     Dim X%
  144.     Dim Y%
  145.     Dim XStep%
  146.     Dim YStep%
  147.     Dim hDCScreen%
  148.     Dim hBrush%
  149.     Dim MyRect As RECT
  150.     Dim di%
  151.     Dim ret%
  152.  
  153. ' Get the form's coordinates and detemine its height and width.
  154.  
  155.     Call GetWindowRect(Frm.hWnd, MyRect)
  156.     
  157.     FormWidth% = MyRect.Right% - MyRect.Left%
  158.     FormHeight% = MyRect.Bottom% - MyRect.Top%
  159.  
  160. ' Get the screen's device context.
  161.  
  162.     hDCScreen% = GetDC(0)
  163.  
  164. ' Create a solid brush that uses the form's background color.
  165.  
  166.     hBrush% = CreateSolidBrush%(Frm.BackColor)
  167.     di% = SelectObject%(hDCScreen%, hBrush%)
  168.  
  169. ' Draw successively larger rectangles until the form's
  170. ' entire area is filled.
  171.  
  172.     For Count% = 1 To STEPS
  173.     XStep% = FormWidth * (Count% / STEPS)
  174.     YStep% = FormHeight * (Count% / STEPS)
  175.     X% = MyRect.Left% + (FormWidth - XStep%) / 2
  176.     Y% = MyRect.Top% + (FormHeight - YStep%) / 2
  177.     ret% = Rectangle%(hDCScreen%, X%, Y%, X% + XStep%, Y% + YStep%)
  178.     Next Count%
  179.  
  180. ' Release the device context and brush, and display the form.
  181.  
  182.     di% = ReleaseDC%(0, hDCScreen%)
  183.     ret% = DeleteObject%(hBrush%)
  184.  
  185. End Sub
  186.  
  187. Sub main ()
  188.  
  189.     Dim ProductName$
  190.     Dim ProductVersion$
  191.     Dim Copyright$
  192.  
  193.     ProductName$ = "AboutWin"
  194.     ProductVersion$ = "1.00a"
  195.     Copyright$ = "Copyright ⌐ 1994 by XYZ."
  196.     
  197.     Load frmAbout
  198.     frmAbout!lblVersion.Caption = ProductName$ & " Version " & ProductVersion$ & " is licensed to:"
  199.     frmAbout!lblCopyright.Caption = Copyright$
  200.     Call FormExplode(frmAbout)
  201.     frmAbout.Show
  202.  
  203. End Sub
  204.  
  205. Sub ShowAbout (ProductId$, Copyright$)
  206.     
  207.     Load frmAbout
  208.     Call FormExplode(frmAbout)
  209.     frmAbout.Show
  210.  
  211. End Sub
  212.  
  213. Function SysDir$ ()
  214.     
  215.     Dim Temp$
  216.     Dim NameLen%
  217.     
  218.     Temp$ = String(255, Chr$(0))
  219.     NameLen% = GetSystemDirectory%(Temp$, Len(Temp$))
  220.     If NameLen% Then
  221.     SysDir$ = Left$(Temp$, NameLen%)
  222.     Else
  223.     SysDir$ = "<Unknown>"
  224.     End If
  225.  
  226. End Function
  227.  
  228. Function WinDir$ ()
  229.     
  230.     Dim Temp$
  231.     Dim NameLen%
  232.     
  233.     Temp$ = String(255, Chr$(0))
  234.     NameLen% = GetWindowsDirectory%(Temp$, Len(Temp$))
  235.     If NameLen% Then
  236.     WinDir$ = Left$(Temp$, NameLen%)
  237.     Else
  238.     WinDir$ = "<Unknown>"
  239.     End If
  240.  
  241. End Function
  242.  
  243.